# Coloured Petri Net (CPN): Input Arc Class
# Release: Development
#
# Copyright (c) 2002 Torvald Riegel. All rights reserved. This program is
# free software; you can redistribute it and/or modify it under the same
# terms as Perl itself.
#
# Copyright (c) 2011 Brent R. Scott. All rights reserved. This program has
# been modified from the original release and is free software. You can 
# redistribute it and/or modify it under the same terms as Perl itself.

package CPN::Transition::ArcIn;

use strict;
use Carp;

sub new {
	my $type = shift;
    my %params = @_;
    return bless {
                  condition => $params{'condition'},
                  place => $params{'place'},
                  transition => $params{'transition'},
                 }, $type;
}

sub setCondition {
    my ($self, $condition) = @_;
    $self->{condition} = $condition;
}
sub setPlace {
	my ($self, $place) = @_;
	$self->{place} = $place;
}
sub setTransition {
	my ($self, $transition) = @_;
	$self->{transition} = $transition;
}


# computes at least one new step that is possible with the available tokens on
# the connected place by using the arc expression. just uses new tokens, but
# creates all steps from used ones
# returns a (BE-list, token-list) pair list
# executes the expression for new tokens until at least one step is found
sub computeNewStep {
    my ($self, $place, $defaultvar) = @_;

    while (defined(my $token = shift @{$self->{newtokens}})) {
        my $gettoken = $place->getToken($token);
        my $result;
        if (defined $self->{condition}) {
            # uses expr
            if (defined($result = $self->{condition}->($gettoken))) {
                next unless $result;
                # creates lists from scalars or hashrefs, skips empty lists
                $result = [$result]
                  if not ref($result) or ref($result) eq 'HASH';
                foreach (@$result) {
                    $_ = {$defaultvar => $_} unless ref $_ eq 'HASH';
                }
            }
        }
        else {
            # expr is assumed to be sub { $t }
            $result = [ { $defaultvar => $gettoken } ];
        }
        if (@$result) {
            return map([$_, [$token]], @$result);
        }
    }
    return ();
}

# params: step number
# returns: new number, step
sub getStep {
    my ($self, $step, $place, $defaultvar) = @_;
    my @result;
    if ($step < @{$self->{cache}}) {
        @result = ($step, $self->{cache}->[$step]);
    }
    else {
        my @newsteps = $self->computeNewStep($place, $defaultvar);
        # TODO: Cache could grow too much if tokens ping-pong
        # shrink/pack the step cache when: transition counter wraps,
        # size treshold reached? (with offset or return new pos to trans?)
        if (@newsteps) {
            push @{$self->{cache}}, @newsteps;
            @result = ($step, $newsteps[0]);
        }
        else {
            # wrap, no step
            @result = (-1, undef);
        }
    }
}

#
# notification about added/removed tokens
#
#params: token ids
sub tokenAdded {
    my $self = shift;
    push @{$self->{newtokens}}, @_;
}

sub tokenRemoved {
    my $self = shift;
    foreach my $token (@_) {
        #removes it from newtokens and cache
        my @nt = grep($_ != $token, @{$self->{newtokens}});
        unless (@nt < @{$self->{newtokens}}) {
            # removes it from cached steps only if it is not new
            foreach (0..$#{$self->{cache}}) {
                next unless $self->{cache}->[$_];
                delete $self->{cache}->[$_]
                  if grep($token == $_, @{$self->{cache}->[$_]->[1]});
            }
        }
        else {
            @{$self->{newtokens}} = @nt;
        }
    }
}

1;